delphi替换QQ托盘图标演示

【例子介绍】

【相关图片】

【源码结构】

unit uMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, CommCtrl, ShellApi, uZHint, uHint2, XPMan, uNotifyIcon,
  Menus, ImgList, ExtCtrls, uTrayIconInject;

type

  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    ZHint1: TZHint;
    Memo1: TMemo;
    Edit1: TEdit;
    CheckBox1: TCheckBox;
    PopupMenu1: TPopupMenu;
    sdfsadf1: TMenuItem;
    asdfasfsadf1: TMenuItem;
    IL: TImageList;
    Timer1: TTimer;
    Button4: TButton;
    Button5: TButton;
    IL2: TImageList;
    Button6: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure Button3Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
  private
    { Private declarations }
    Tray: TTrayIcon;
    FHint2: THint2;
    FOldPos: TPoint;
    FCapture: Boolean;
    FCount: Integer;
    FFram: Integer;
    Extra: TTButtonExtraInfo;
    procedure PopTip;
    procedure OnShowHint(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses Types;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
  if Tray.IconCount >= IL.Count then
    Exit;
  
  IL.GetIcon(Tray.IconCount, Icon);
  Tray.NotifyIcon('Tray'   IntToStr(GetTickCount), Icon.Handle,  '自定义提示', '已加入到通知区域 '
      FormatDateTime('yyyy-mm-dd hh:mm:ss', Now), [ntIcon, ntInfo, ntMouseHint], True);
end;

{ TTrayIcon }


procedure TForm1.FormCreate(Sender: TObject);
begin
  Tray := TTrayIcon.Create;
  Tray.Menu := PopupMenu1;
  FHint2 := THint2.Create('', '', 0);
  Application.OnShowHint := OnShowHint;
  Button1Click(Button1);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  Tray.RemoveIcon(0);

end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  Tray.Free;
  FHint2.Free;
end;

procedure TForm1.PopTip;
var
  Param: THintShowParam;
  Pos2: TPoint;
begin
  FillChar(Param, sizeof(Param), 0);
  GetCursorPos(Pos2);
  with Param do begin
    Param.Pos := Pos2;
    Param.Title := Edit1.Text;
    Param.Info := Memo1.Text;
    Param.TimeOut := 5000;
    Param.BkColor := clCream;
    Param.BorderColor := $968157;
    TitleBkColor := $00E2E1C7;//$00FF8080;
    TitleFont.Name := '宋体';
    TitleFont.Style := [fsBold];
    TitleFont.Color := clBlack;
    TitleFont.Size := 9;
    InfoFont.Name := 'MONO';
    InfoFont.Size := 9;
    TimeOut := 3000;
    if CheckBox1.Checked then
      Round := 3
    else
      Round := 0;

    ParentWnd := Handle;
    InfoFont.Color := clRed;
    Param.AlphaBlendValue := 255;
    Param.Flag := HF_ALPHABLEND;
  end;
  FHint2.ShowHint(Param);
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
//
  FCapture := True;
  SetCapture(Handle);
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
//
  FCapture := False;
  ReleaseCapture;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
//
  if not FCapture then
    Exit;

  if (FOldPos.X <> X) or (FOldPos.Y <> Y) then  begin
    FOldPos.X := X;
    FOldPos.Y := Y;
    PopTip;
  end
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key = VK_ESCAPE then
    FHint2.HideHint;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
//
  Tray.NotifyIcon(0, Application.Icon.Handle, Edit1.Text, Memo1.Text, [ntIcon, ntInfo]);
end;

procedure TForm1.OnShowHint(var HintStr: string; var CanShow: Boolean;
  var HintInfo: THintInfo);
var
  Param: THintShowParam;
  Pos2: TPoint;
begin
  CanShow := False;
  FillChar(Param, sizeof(Param), 0);

  with Param do begin
    Windows.ClientToScreen(TWinControl(HintInfo.HintControl).Handle, HintInfo.CursorPos);
    Param.Pos := HintInfo.CursorPos;
    Param.Title := HintInfo.HintControl.Name;
    Param.Info := HintStr;
    Param.TimeOut := HintInfo.HideTimeout;
    Param.BkColor := clCream;
    Param.BorderColor := $968157;
    TitleBkColor := $00E2E1C7;//$00FF8080;
    TitleFont.Name := '宋体';
    TitleFont.Style := [fsBold];
    TitleFont.Color := clBlack;
    TitleFont.Size := 9;
    InfoFont.Name := 'MONO';
    InfoFont.Size := 9;
    if CheckBox1.Checked then
      Round := 3
    else
      Round := 0;
      
    InfoFont.Color := clRed;
    Param.AlphaBlendValue := 230;
    Param.Flag := HF_ALPHABLEND;
  end;
  FHint2.ShowHint(Param);
end;


function NotifyIcon(const Extra: TTButtonExtraInfo; Icon: TIcon): Boolean;
var
  NI: TNotifyIconData5;
  ret: Boolean;
  Code: Integer;
begin
  Result := True;
  FillChar(NI, sizeof(NI), 0);
  NI.cbSize := sizeof(NI);
  NI.uID := Extra.ID;
  NI.Wnd := Extra.Wnd;
  NI.Icon := Icon.Handle;
  NI.uFlags := NIF_ICON or NIF_INFO;

  NI.dwInfoFlag := 1;
  NI.uTimeOut := 300;
  NI.szTip := '';
  NI.szInfoTitle := '找到QQ';
  StrLCopy(NI.szInfo, PChar('QQ 图标已替换. '  FormatDateTime('yyyy-mm-dd hh:mm:ss', Now)), sizeof(NI.szInfo));
  
  Ret := Shell_NotifyIcon(NIM_MODIFY, @NI);
end;



procedure TForm1.Timer1Timer(Sender: TObject);
begin
  if FCount > 4 then begin
    FCount := 0;
    if FFram = 0 then
      FFram := 1
    else
      FFram := 0;

    IL2.GetIcon(FFram, Icon);
    
    FIndWndExtra('TXGuiFoundation', NotifyIcon, Icon);
  end else begin
    Inc(FCount);
  end;

end;

procedure TForm1.Button4Click(Sender: TObject);
begin
  Timer1.Enabled := True;
end;

procedure TForm1.Button5Click(Sender: TObject);
begin
  Timer1.Enabled := False;
end;

procedure TForm1.Button6Click(Sender: TObject);
var
  Param: THintShowParam;
  Pt: TPoint;
begin
  Pt := Memo1.BoundsRect.TopLeft;
  Windows.ClientToScreen(Handle, Pt);

  FillChar(Param, sizeof(Param), 0);
  with Param do begin
    Pos := Pt;
    Title := Edit1.Text;
    Info := Memo1.Text;
    BkColor := clCream;
    BorderColor := $968157;
    TitleBkColor := $00E2E1C7;//$00FF8080;
    TitleFont.Name := '宋体';
    TitleFont.Style := [fsBold];
    TitleFont.Color := clBlack;
    TitleFont.Size := 9;
    InfoFont.Name := 'MONO';
    InfoFont.Size := 9;
    InfoFont.Color := ColorToRGB(clWindowText);
    TimeOut := 5000;
    Round := 3;

    ParentWnd := Handle;
    Param.AlphaBlendValue := 230;
    Param.Flag := HF_ALPHABLEND;
  end;

  FHint2.ShowHint(Param);
end;

end.